home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / acad / autolisp / wblk / wblk.lsp
Lisp/Scheme  |  1992-01-05  |  6KB  |  111 lines
  1. ;;; -*-  Mode: LISP -*- (C) Ben Olasov 1991
  2. ;;; Writes all blocks references in drawing to specified directory.
  3. ;;; DOS version
  4.  
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;;; File: WBLCK.LSP     Copyright (C) Ben Olasov 1991  All Rights Reserved  ;;;
  7. ;;; Inquiries:                                                              ;;;
  8. ;;;                                                                         ;;;
  9. ;;;       Ben Olasov     Lispenard Technologies                             ;;;
  10. ;;;                      New York, NY                                       ;;;
  11. ;;;                                                                         ;;;
  12. ;;;                      Voice:    (212) 274-8506                           ;;;
  13. ;;;                      FAX:      (212) 979-3686                           ;;;
  14. ;;;                      Arpanet:  olasov@cs.columbia.edu                   ;;;
  15. ;;;                      Internet: ben@syska.com                            ;;;
  16. ;;;                                                                         ;;;
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19. (VMON)
  20. (gc)
  21.  
  22. (princ "\nLoading- please wait...")
  23.  
  24. ;; creates wblocks in user-specified path of all blocks in drawing
  25. (defun c:wblk (/ dwgpfx blks tmp foo)
  26.       (setq cmdecho (getvar "cmdecho")
  27.             dwgpfx (getvar "dwgprefix")
  28.             output_path (parse_path (userstr (if output_path output_path dwgpfx)
  29.                                          "\nOutput blocks to which directory")))
  30.       (setvar "cmdecho" 0)
  31.       (setq blks (cdr (assoc 2 (tblnext "BLOCK" T)))
  32.             blks (list (cdr (assoc 2 (tblnext "BLOCK"))) blks))
  33.       (while (setq tmp (tblnext "BLOCK")) 
  34.              (setq blks (cons (cdr (assoc 2 tmp)) blks)))
  35.       (foreach X (clean_blklist blks)
  36.                (if (and (<= (strlen X) 8) (/= (substr x 1 1) "*"))
  37.                    (progn (setq foo (open (strcat output_path x ".dwg") "r"))
  38.                           (if foo (progn (close foo)
  39.                                          (princ (strcat "\nDrawing "
  40.                                                         output_path
  41.                                                         X
  42.                                                         " already exists!")))
  43.                                   (progn (princ (strcase (strcat "\nWriting " output_path X ".dwg") t))
  44.                                          (command "wblock" (strcat output_path X) X))))))
  45.       (setvar "cmdecho" cmdecho)
  46.        'done)
  47.  
  48. ;; get a user string with default
  49. (defun userstr (dflt prmpt / var) ;;DFLT and PRMPT are strings
  50.        (setq var (getstring (if (and dflt (/= dflt ""))
  51.                                 (strcat prmpt " <" dflt ">: ")
  52.                                 (strcat prmpt ": "))))
  53.        (cond ((/= var "") var)
  54.              ((and dflt (= var "")) dflt)
  55.              (T "")))
  56.  
  57. ;; parse a user's path response
  58. (defun parse_path (s / STRL FIRSTC SECONDC LASTC)
  59.        (cond ((null s) nil) ;; is S bound?
  60.              ((= s "") s)   ;; is S an empty string?
  61.              (T (setq STRL (strlen s)
  62.                       FIRSTC (substr s 1 1)
  63.                       SECONDC (substr s 2 1)
  64.                       LASTC (substr s STRL 1))
  65.                 (cond ((= STRL 1)  ;; if S has only one character
  66.                        (if (or (= FIRSTC "/")   ;; and the 1st char is "/"
  67.                                (= FIRSTC "\\")) ;; or "\\"
  68.                            "\\"                 ;; return the 1st char
  69.                            (strcat DWGPFX S "\\"))) ;; otherwise prepend DWGPFX
  70.                                                    ;; and append a "\\"
  71.                       ((or (and (= FIRSTC "/")  ;; if the user pathname
  72.                                 (= LASTC "/"))  ;; looks superficially
  73.                            (and (= FIRSTC "\\") ;; well-formed, return it.
  74.                                 (= LASTC "\\"))) S)
  75.                       ((and (/= FIRSTC "/")
  76.                             (/= FIRSTC "\\"))  ;; the 1st char isn't /
  77.                        (cond ((= SECONDC ":")  ;; is it a drive spec?
  78.                               (if (and (/= LASTC "/") ;; make sure there's
  79.                                        (/= LASTC "\\")) ;; a slash on the end
  80.                                   (strcat S "\\")
  81.                                   S))
  82.                              ((and (/= LASTC "/")
  83.                                    (/= LASTC "\\"))
  84.                               (strcat DWGPFX S "\\"))))
  85.                       (T s)))))
  86.  
  87. ;; removes atom ATM from list of unique atoms LST
  88. (defun aux_remove (atm lst) 
  89.      (cond ((null lst) NIL) 
  90.            ((null (member atm lst)) lst) 
  91.            ((equal atm (car lst)) 
  92.             (cdr lst)) 
  93.            (t (append (reverse (cdr (member atm (reverse lst))))
  94.                       (cdr (member atm lst)))))) 
  95.  
  96. ;; removes HATCH references and blocks with names longer than 8 chars
  97. (defun clean_blklist (blklist / bl)
  98.        (setq bl blklist)
  99.        (if (and bl (listp bl))
  100.            (foreach blk bl
  101.                     (if (or (null blk)
  102.                             (= (substr blk 1 1) "*")
  103.                             (> (strlen blk) 8))
  104.                         (progn (princ (strcat
  105.              "\nRemoving " blk " from block list."))
  106.                                (setq bl (aux_remove blk bl))))))
  107.        bl)
  108.  
  109. (princ "\nType WBLK to write out all block references to a user-specified directory.")
  110. (princ)
  111.